{*******************************************************************************
* The contents of this file are used with permission, subject to the Mozilla   *
* Public License Version 1.1 (the "License"); you may not use this file except *
* in compliance with the License. You may obtain a copy of the License at      *
* http://www.mozilla.org/MPL/                                                  *
*                                                                              *
* Software distributed under the License is distributed on an "AS IS" basis,   *
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for *
* the specific language governing rights and limitations under the License.    *
*                                                                              *
* The Original Code is distributed as part of the "mediate" product and is     *
* Copyright (C) @home media limited. All Rights Reserved.                      *
*                                                                              *
* Email: support@athomemedia.co.uk                                             *
* Web:   http://www.athomemedia.co.uk                                          *
*******************************************************************************}

unit Canvas;

interface

uses Classes, Graphics, Windows, Graphic, Colour, Types, AHMTypes, Scrolling,
     GDIPAPI, GDIPOBJ;

const
  MIN_SCALE = 0.01; // Minimum scale to prevent division by zero errors
  CLIP_SCALE = 0.015; // Minimum scale for clipping small objects
  MAX_SCALE = 10.0; // Maximum scale to prevent rendering huge (slow) objects
  CHAR_TAB = 9; // Tab character (supported by font renderer)
  CHAR_LF = 10; // Line feed character (supported by font renderer)
  CHAR_CR = 13; // Carriage return character (supported by font renderer)
  CHAR_SPC = 32; // Space character (supported by font renderer)
  CHAR_CURSOR = 31; // Fake character used for rendering text cursor

type
  TAHMTextAlign = (taUnknown, taLeft, taRight, taCenter);

  TAHMCanvasFont = class(TPersistent)
  private
    FCached: Boolean;
    FTypeface: String;
    FSize: Integer;
    FOriginalSize: Integer;
    FColour: TAHMCanvasColour;
    FBold: Boolean;
    FItalic: Boolean;
    FUnderline: Boolean;
    FShadow: Boolean;
    FShadowColour: TAHMCanvasColour;
    FShadowX, FShadowY: Single;
    FOutline: Boolean;
    FOutlineWidth: Single;
    FOutlineColour: TAHMCanvasColour;
    FGlow: Boolean;
  protected
    procedure SetSize(Size: Integer);
  public
    property Cached: Boolean read FCached write FCached;
    property Colour: TAHMCanvasColour read FColour write FColour;
    property ShadowColour: TAHMCanvasColour read FShadowColour write FShadowColour;
    property OutlineColour: TAHMCanvasColour read FOutlineColour write FOutlineColour;
    property Typeface: String read FTypeface write FTypeface;
    property Size: Integer read FSize write SetSize;
    property OriginalSize: Integer read FOriginalSize;
    property Bold: Boolean read FBold write FBold;
    property Italic: Boolean read FItalic write FItalic;
    property Underline: Boolean read FUnderline write FUnderline;
    property Shadow: Boolean read FShadow write FShadow;
    property ShadowXOffset: Single read FShadowX write FShadowX;
    property ShadowYOffset: Single read FShadowY write FShadowY;
    property Outline: Boolean read FOutline write FOutline;
    property OutlineWidth: Single read FOutlineWidth write FOutlineWidth;
    property Glow: Boolean read FGlow write FGlow;
    procedure Assign(Source: TPersistent); override;
    procedure Invalidate;
    procedure ScaleFont(Scale: Single);
    procedure Clear;
    // Class functions for standard fonts
    class function Default: TAHMCanvasFont;
  end;

  TAHMDrawBuffer = class;

  TAHMCanvas = class
  private
    FPenWidth: Single;
    FPenColour: TAHMCanvasColour;
    FBrushColour: TAHMCanvasColour;
    FGammaCalc: TAHMCanvasColour;
    FHandle: HDC;
    FBuffer: TAHMDrawBuffer;
    FGraphics: TGPGraphics;
    FPen: TGPPen;
    FBrush: TGPSolidBrush;
    FFont: TGPFont;
    FFontSize: Single;
    FFontOutline: Single;
    FFontStyle: TFontStyle;
    FFontPath: TGPGraphicsPath;
    FFontFormat: TGPStringFormat;
    FFontFamily: TGPFontFamily;
    FRotationLocked: Boolean;
    function GetFontCount: Integer;
    function GetGraphicCount: Integer;
    function GetDiagnostics: String;
    procedure SetGDIHandle(Handle: HDC);
    procedure SetGDIBuffer(Buffer: TAHMDrawBuffer);
  protected
    property InternalBuffer: TAHMDrawBuffer read FBuffer write SetGDIBuffer;
  public
    constructor Create;
    destructor Destroy; override;
    property InternalHandle: HDC read FHandle write SetGDIHandle;
    property PenWidth: Single read FPenWidth write FPenWidth;
    property PenColour: TAHMCanvasColour read FPenColour write FPenColour;
    property BrushColour: TAHMCanvasColour read FBrushColour write FBrushColour;
    property FontCount: Integer read GetFontCount;
    property GraphicCount: Integer read GetGraphicCount;
    property DiagnosticMessage: String read GetDiagnostics;
    procedure SetRotation(XRotation, YRotation, ZRotation: Single; XOrigin, YOrigin: Single);
    procedure Set3DRotation(XRotation, YRotation, ZRotation: Single);
    procedure Set3DRotateOrigin(XOrigin, YOrigin, XWidth, YHeight: Single);
    procedure LockRotation;
    procedure UnlockRotation;
    procedure UnSetRotation;
    procedure UnSet3DRotation;
    procedure Clear;
    procedure DesignerBackground(Rect: TAHMRectF);
    procedure DesignerShape(Rect: TAHMRectF; Gamma: TAHMCanvasColour; XScale, YScale: Single; XFlip, YFlip: Boolean);
    procedure DesignerCrossHair(X, Y, Width, Height: Single);
    procedure DesignerGrabHandle(X, Y: Single; Active: Boolean);
    procedure DesignerOutline(Rect: TAHMRectF; Active: Boolean);
    procedure CheckerBoard(Rect: TAHMRectF; Rows, Columns: Integer);
    procedure DrawCircle(X, Y, Radius: Single; Gamma: TAHMCanvasColour);
    procedure DrawEllipse(X, Y, XRadius, YRadius: Single; Gamma: TAHMCanvasColour);
    procedure DrawArc(X, Y, XRadius, YRadius, StartAngle, SweepAngle: Single; Gamma: TAHMCanvasColour);
    procedure FillCircle(X, Y, Radius: Single; Gamma: TAHMCanvasColour);
    procedure FillEllipse(X, Y, XRadius, YRadius: Single; Gamma: TAHMCanvasColour);
    procedure FillRect(Rect: TAHMRectF); overload;
    procedure FillRect(Rect: TAHMRectF; Shade: TAHMCanvasShade; Gamma: TAHMCanvasColour; XScale, YScale: Single); overload;
    procedure FillRect(Rect, ClipRect: TAHMRectF; Shade: TAHMCanvasShade; Gamma: TAHMCanvasColour; XScale, YScale: Single); overload;
    procedure FillRoundRect(Rect: TAHMRectF; Gamma: TAHMCanvasColour; CornerRadius, XScale, YScale: Single); overload;
    procedure ClearRect(Rect: TAHMRectF);
    procedure DrawGraphic(Rect: TAHMRectF; Graphic: TAHMGraphic; Shade: TAHMCanvasShade; Gamma: TAHMCanvasColour;
                          XScale, YScale: Single; XFlip, YFlip: Boolean); overload;
    procedure DrawGraphic(Rect, ClipRect: TAHMRectF; Graphic: TAHMGraphic; Shade: TAHMCanvasShade; Gamma: TAHMCanvasColour;
                          XScale, YScale: Single; XFlip, YFlip: Boolean); overload;
    procedure TextRect(Rect: TAHMRectF; Font: TAHMCanvasFont; Text: String); overload;
    procedure TextRect(Rect: TAHMRectF; Font: TAHMCanvasFont; Text: String; Align: TAHMTextAlign;
                       WordWrap: Boolean; Scroller: TAHMAbstractScroller; Shade: TAHMCanvasShade;
                       Gamma: TAHMCanvasColour; XScale, YScale: Single; XFlip, YFlip: Boolean); overload;
    procedure TextRect(Rect, ClipRect: TAHMRectF; Font: TAHMCanvasFont; Text: String; Align: TAHMTextAlign;
                       WordWrap: Boolean; Scroller: TAHMAbstractScroller; Shade: TAHMCanvasShade;
                       Gamma: TAHMCanvasColour; XScale, YScale: Single; XFlip, YFlip: Boolean); overload;
    procedure ReleaseFont(Font: TAHMCanvasFont);
    procedure Rectangle(Rect: TAHMRectF; Gamma: TAHMCanvasColour); overload;
    procedure Rectangle(Rect: TAHMRectF; Gamma: TAHMCanvasColour; XScale, YScale: Single); overload;
    procedure RoundRect(Rect: TAHMRectF; Gamma: TAHMCanvasColour; CornerRadius: Single); overload;
    procedure RoundRect(Rect: TAHMRectF; Gamma: TAHMCanvasColour; CornerRadius, XScale, YScale: Single); overload;
    procedure MoveTo(X, Y: Single);
    procedure LineTo(X, Y: Single; Gamma: TAHMCanvasColour);
    procedure Line(Rect: TAHMRectF; Gamma: TAHMCanvasColour);
    function PrepareGDIText(Font: TAHMCanvasFont): Single;
    procedure UnPrepareGDIText;
    procedure MeasureGDIText(var Rect: TAHMRectF; Text: WideString);
    procedure DrawGDIText(X, Y: Single; Text: WideString);
  end;

  TAHMDrawBuffer = class
  private
    FAlphaBlending: Boolean;
    FMonochrome: Boolean;
    FBitmapFormat: TPixelFormat;
    FByteFormat: TAHMTextureFormat;
    FWidth, FHeight: Integer;
    FCanvas: TAHMCanvas;
    FBuffer: TGPBitmap;
    FLocked: Boolean;
    FLockData: TBitmapData;
  protected
    property Bitmap: TGPBitmap read FBuffer;
    procedure SetWidth(Width: Integer);
    procedure SetHeight(Height: Integer);
    function GetBufferRect: TAHMRect;
    procedure AllocateBitmap;
  public
    constructor Create;
    destructor Destroy; override;
    property AlphaBlending: Boolean read FAlphaBlending write FAlphaBlending;
    property Monochrome: Boolean read FMonoChrome write FMonochrome;
    property Width: Integer read FWidth write SetWidth;
    property Height: Integer read FHeight write SetHeight;
    property BufferRect: TAHMRect read GetBufferRect;
    property Canvas: TAHMCanvas read FCanvas;
    function ProcessBitmap(Process: TAHMBitmapProcess): Boolean;
    function LockBitmap(Rect: TAHMRect; var Lock: TAHMBitmapData): Boolean;
    procedure UnlockBitmap;
    procedure SaveBitmap(Filename: String);
  end;

  function MakeRect(X, Y, Width, Height: Integer): TAHMRect;
  function MakeRectF(X, Y, Width, Height: Single): TAHMRectF; overload;
  function MakeRectF(Rect: TAHMRect): TAHMRectF; overload;
  function MakeRectF(Rect: TRect): TAHMRectF; overload;
  procedure ClipRect(var Rect: TAHMRect; Bounds: TAHMRect); overload;
  procedure ClipRect(var Rect: TAHMRectF; Bounds: TAHMRectF); overload;
  function ShrinkRect(Rect: TAHMRect; DX, DY: Integer): TAHMRect; overload;
  function ShrinkRect(Rect: TAHMRectF; DX, DY: Single): TAHMRectF; overload;
  function ScaleRect(Rect: TAHMRectF; XScale, YScale: Single): TAHMRectF;
  function GetIntegerRect(Rect: TAHMRectF): TAHMRect;
  function GetNativeRect(Rect: TAHMRect): TRect; overload;
  function GetRoundedNativeRect(Rect: TAHMRectF): TRect;

implementation

uses SysUtils, Math, Screen, DirectXHelper, ImageProcessing, Logging, GDIPUTIL;

var
  DefaultFontInstance: TAHMCanvasFont;


function MakeRect(X, Y, Width, Height: Integer): TAHMRect;
begin
  Result := TAHMRect(GDIPAPI.MakeRect(X, Y, Width, Height));
end;

function MakeRectF(X, Y, Width, Height: Single): TAHMRectF;
begin
  Result := TAHMRectF(GDIPAPI.MakeRect(X, Y, Width, Height));
end;

function MakeRectF(Rect: TAHMRect): TAHMRectF;
begin
  Result := MakeRectF(Rect.X, Rect.Y, Rect.Width, Rect.Height);
end;

function MakeRectF(Rect: TRect): TAHMRectF;
begin
  Result := MakeRectF(Rect.Left, Rect.Top, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top);
end;

procedure ClipRect(var Rect: TAHMRect; Bounds: TAHMRect);
var
  RectR, RectB, BoundsR, BoundsB: Integer;
begin
  // Calculate bottom and right edges
  RectR := Rect.X + Rect.Width;
  RectB := Rect.Y + Rect.Height;
  BoundsR := Bounds.X + Bounds.Width;
  BoundsB := Bounds.Y + Bounds.Height;

  // Clip rectangle to boundary rectangle
  if Rect.X < Bounds.X then Rect.X := Bounds.X;
  if RectR > BoundsR then RectR := BoundsR;
  if Rect.Y < Bounds.Y then Rect.Y := Bounds.Y;
  if RectB > BoundsB then RectB := BoundsB;

  // Calculate revised width and height
  Rect.Width := RectR - Rect.X;
  Rect.Height := RectB - Rect.Y;
end;

procedure ClipRect(var Rect: TAHMRectF; Bounds: TAHMRectF);
var
  RectR, RectB, BoundsR, BoundsB: Single;
begin
  // Calculate bottom and right edges
  RectR := Rect.X + Rect.Width;
  RectB := Rect.Y + Rect.Height;
  BoundsR := Bounds.X + Bounds.Width;
  BoundsB := Bounds.Y + Bounds.Height;

  // Clip rectangle to boundary rectangle
  if Rect.X < Bounds.X then Rect.X := Bounds.X;
  if RectR > BoundsR then RectR := BoundsR;
  if Rect.Y < Bounds.Y then Rect.Y := Bounds.Y;
  if RectB > BoundsB then RectB := BoundsB;

  // Calculate revised width and height
  Rect.Width := RectR - Rect.X;
  Rect.Height := RectB - Rect.Y;
end;

function ShrinkRect(Rect: TAHMRect; DX, DY: Integer): TAHMRect;
begin
  Result.X := Rect.X + DX;
  Result.Y := Rect.Y + DY;
  Result.Width := Rect.Width - (DX * 2);
  Result.Height := Rect.Height - (DY * 2);
end;

function ShrinkRect(Rect: TAHMRectF; DX, DY: Single): TAHMRectF;
begin
  Result.X := Rect.X + DX;
  Result.Y := Rect.Y + DY;
  Result.Width := Rect.Width - (DX * 2);
  Result.Height := Rect.Height - (DY * 2);
end;

function ScaleRect(Rect: TAHMRectF; XScale, YScale: Single): TAHMRectF;
var
  X, Y: Single;
begin
  // Calculate mid point of rect
  X := Rect.X + (Rect.Width / 2);
  Y := Rect.Y + (Rect.Height / 2);

  // Scale dimensions
  Result.Width := Rect.Width * XScale;
  Result.Height := Rect.Height * YScale;

  // Calculate new top left position
  Result.X := X - (Result.Width / 2);
  Result.Y := Y - (Result.Height / 2);
end;

function GetIntegerRect(Rect: TAHMRectF): TAHMRect;
begin
  Result.X := Round(Rect.X);
  Result.Y := Round(Rect.Y);
  Result.Width := Round(Rect.Width);
  Result.Height := Round(Rect.Height);
end;

function GetNativeRect(Rect: TAHMRect): TRect;
begin
  Result.Left := Rect.X;
  Result.Top := Rect.Y;
  Result.Right := Rect.X + Rect.Width;
  Result.Bottom := Rect.Y + Rect.Height;
end;

function GetRoundedNativeRect(Rect: TAHMRectF): TRect;
begin
  Result.Left := Round(Rect.X);
  Result.Top := Round(Rect.Y);
  Result.Right := Round(Rect.X + Rect.Width);
  Result.Bottom := Round(Rect.Y + Rect.Height);
end;


//----------------------------------------------------------------------------//

procedure TAHMCanvasFont.SetSize(Size: Integer);
begin
  FSize := Size;
  FOriginalSize := Size;
end;

procedure TAHMCanvasFont.Assign(Source: TPersistent);
begin
  if Source is TAHMCanvasFont then
  begin
    FTypeFace := TAHMCanvasFont(Source).Typeface;
    FColour := TAHMCanvasFont(Source).Colour;
    FSize := TAHMCanvasFont(Source).Size;
    FOriginalSize := TAHMCanvasFont(Source).Size;
    FBold := TAHMCanvasFont(Source).Bold;
    FItalic := TAHMCanvasFont(Source).Italic;
    FUnderline := TAHMCanvasFont(Source).Underline;
    FShadow := TAHMCanvasFont(Source).Shadow;
    FShadowColour := TAHMCanvasFont(Source).ShadowColour;
    FShadowX := TAHMCanvasFont(Source).ShadowXOffset;
    FShadowY := TAHMCanvasFont(Source).ShadowYOffset;
    FOutline := TAHMCanvasFont(Source).Outline;
    FOutlineWidth := TAHMCanvasFont(Source).OutlineWidth;
    FOutlineColour := TAHMCanvasFont(Source).OutlineColour;
    FGlow := TAHMCanvasFont(Source).Glow;
  end;
end;

procedure TAHMCanvasFont.Invalidate;
begin
  // Flag font as no longer cached, DirectX layer will then rebuild it
  FCached := False;
end;

procedure TAHMCanvasFont.ScaleFont(Scale: Single);
begin
  // Tweak size but don't change original size in case we get scaled again
  FSize := Round(FOriginalSize * Scale);
end;

procedure TAHMCanvasFont.Clear;
begin
  FCached := False;
  FTypeface := '';
  FSize := 0;
  FOriginalSize := 0;
  FColour := nil;
  FBold := False;
  FItalic := False;
  FUnderline := False;
  FShadow := False;
  FShadowColour := nil;
  FShadowX := 0;
  FShadowY := 0;
  FOutline := False;
  FOutlineWidth := 0;
  FOutlineColour := nil;
  FGlow := False;
end;

class function TAHMCanvasFont.Default: TAHMCanvasFont;
begin
  if DefaultFontInstance = nil then
  begin
    DefaultFontInstance := TAHMCanvasFont.Create;
    DefaultFontInstance.Typeface := 'Lucida Console';
    DefaultFontInstance.Size := 12;
    DefaultFontInstance.Colour := TAHMCanvasColour.Black;
  end;
  Result := DefaultFontInstance;
end;

//----------------------------------------------------------------------------//

constructor TAHMCanvas.Create;
begin
  inherited;

  // Create a temporary colour for gamma correction
  FGammaCalc := TAHMCanvasColour.Create;
end;

destructor TAHMCanvas.Destroy;
begin
  // Ensure we free our GDI graphics object
  FGraphics.Free;
  FGammaCalc.Free;

  inherited Destroy;
end;

function TAHMCanvas.GetFontCount: Integer;
begin
  // Delegate to DirectX layer
  Result := DirectXInstance.FontManager.Count;
end;

function TAHMCanvas.GetGraphicCount: Integer;
begin
  // Delegate to DirectX layer
  Result := DirectXInstance.SpriteManager.Count;
end;

function TAHMCanvas.GetDiagnostics: String;
begin
  // Delegate to DirectX layer
  Result := DirectXInstance.DiagnosticMessage;
end;

procedure TAHMCanvas.SetGDIHandle(Handle: HDC);
begin
  // Free any previous GDI+ wrapper object
  FreeAndNil(FGraphics);

  // Create a new GDI+ wrapper to work with passed device context
  FGraphics := TGPGraphics.Create(Handle);

  // Store new device context and clear buffer property
  FHandle := Handle;
  FBuffer := nil;
end;

procedure TAHMCanvas.SetGDIBuffer(Buffer: TAHMDrawBuffer);
begin
  // Free any previous GDI+ wrapper object
  FreeAndNil(FGraphics);

  // Create a new GDI+ wrapper to work with passed image buffer
  FGraphics := TGPGraphics.Create(Buffer.Bitmap);

  // Store new image buffer and update device context property
  FHandle := 0;
  FBuffer := Buffer;
end;

procedure TAHMCanvas.SetRotation(XRotation, YRotation, ZRotation: Single; XOrigin, YOrigin: Single);
begin
  // Ignore request if rotation is locked
  if FRotationLocked then Exit;

  // Set rotation transform in DirectX layer
  DirectXInstance.SetRotation(XRotation, YRotation, ZRotation, XOrigin, YOrigin);
end;

procedure TAHMCanvas.Set3DRotation(XRotation, YRotation, ZRotation: Single);
begin
  // Setup 3D rotation angle in DirectX layer
  DirectXInstance.Set3DRotation(XRotation, YRotation, ZRotation);
end;

procedure TAHMCanvas.Set3DRotateOrigin(XOrigin, YOrigin, XWidth, YHeight: Single);
begin
  // Setup 3D rotation origin in DirectX layer
  DirectXInstance.Set3DRotateOrigin(XOrigin, YOrigin, XWidth, YHeight);
end;

procedure TAHMCanvas.LockRotation;
begin
  // Set rotation lock
  FRotationLocked := True;
end;

procedure TAHMCanvas.UnlockRotation;
begin
  // Reset rotation lock
  FRotationLocked := False;
end;

procedure TAHMCanvas.UnSetRotation;
begin
  // Ignore request if rotation is locked
  if FRotationLocked then Exit;

  // Unset DirectX rotation transform
  DirectXInstance.ResetRotation;
end;

procedure TAHMCanvas.UnSet3DRotation;
begin
  // Unset DirectX 3D rotation properties
  DirectXInstance.Reset3DRotation;
end;

procedure TAHMCanvas.Clear;
begin
  // Ensure we have a bitmap buffer allocated before clearing canvas
  if Assigned(FBuffer) then FBuffer.AllocateBitmap;

  FGraphics.Clear(aclTransparent);
end;

procedure TAHMCanvas.DesignerBackground(Rect: TAHMRectF);
begin
  // Render background for designer preview
//TODO: add preference setting to tweak this later
  FBrushColour := TAHMCanvasColour.White;
  FillRect(Rect, nil, nil, 1.0, 1.0);
  FBrushColour := TAHMCanvasColour.Grey;
  CheckerBoard(Rect, 15, 15);
end;

procedure TAHMCanvas.DesignerShape(Rect: TAHMRectF; Gamma: TAHMCanvasColour;
                                   XScale, YScale: Single; XFlip, YFlip: Boolean);
var
  Inner: TAHMRectF;
begin
  // Reduce dimensions to compensate for line width
  FPenWidth := Rect.Width / 10;
  Inner := ShrinkRect(Rect, FPenWidth, FPenWidth);

  // Render simple black and white frame for designer preview
  FPenColour := TAHMCanvasColour.Black;
  Rectangle(Inner, Gamma, XScale, YScale);
  FPenColour := TAHMCanvasColour.White;
  FPenWidth := Rect.Width / 12;
  Rectangle(Inner, Gamma, XScale, YScale);
end;

procedure TAHMCanvas.DesignerCrossHair(X, Y, Width, Height: Single);
begin
  // Render black cross hair and highlight rectangle at specified point
  FBrushColour := TAHMCanvasColour.Highlight;
  FPenColour := TAHMCanvasColour.Black;
  FPenWidth := 0.001;
  FillRect(MakeRectF(X, Y, Width, Height));
  Line(MakeRectF(X, Y - Height / 2, 0, Height), nil);
  Line(MakeRectF(X - Width / 2, Y, Width, 0), nil)
end;

procedure TAHMCanvas.DesignerGrabHandle(X, Y: Single; Active: Boolean);
begin
  // Render grab handle with optional highlighting at specified point
  if Active then FBrushColour := TAHMCanvasColour.GradientHi
            else FBrushColour := TAHMCanvasColour.GradientLo;
  FillCircle(X, Y, 0.013, nil);
  if Active then FBrushColour := TAHMCanvasColour.White
            else FBrushColour := TAHMCanvasColour.Highlight;
  FillCircle(X, Y, 0.010, nil);
end;

procedure TAHMCanvas.DesignerOutline(Rect: TAHMRectF; Active: Boolean);
begin
  // Draw outline with optional highlighting
  if Active then FPenColour := TAHMCanvasColour.GradientHi
            else FPenColour := TAHMCanvasColour.GradientLo;
  PenWidth := 0.004;
  Rectangle(Rect, nil);
  if Active then FPenColour := TAHMCanvasColour.White
            else FPenColour := TAHMCanvasColour.Highlight;
  PenWidth := 0.002;
  Rectangle(Rect, nil);
end;

procedure TAHMCanvas.CheckerBoard(Rect: TAHMRectF; Rows, Columns: Integer);
var
  x, y: Integer;
  DestRect: TAHMRectF;
begin
  if (Rows > 0) and (Columns > 0) then
  begin
    // Calculate size of each rectangle
    DestRect := MakeRectF(0, 0, Rect.Width / Columns, Rect.Height / Rows);
    Rect.X := Rect.X + Rect.Width;

    for y := 0 to Pred(Rows) do
    begin
      // Calculate Y coordinate
      DestRect.Y := y * DestRect.Height;
      for x := 0 to Columns div 2 do
      begin
        // Calculate X coordinate
        if (y mod 2) = 0 then DestRect.X := (x * 2) * DestRect.Width
                         else DestRect.X := (x * 2 + 1) * DestRect.Width;
        if DestRect.X < Rect.X then
          DirectXInstance.FillRect(DestRect, nil, FBrushColour, 1.0, 1.0);
      end;
    end;
  end;
end;

procedure TAHMCanvas.DrawCircle(X, Y, Radius: Single; Gamma: TAHMCanvasColour);
begin
  // Delegate this task to DirectX layer
  if Assigned(FPenColour) then
    DirectXInstance.DrawCircle(X, Y, Radius, FPenWidth, FPenColour, Gamma);
end;

procedure TAHMCanvas.DrawEllipse(X, Y, XRadius, YRadius: Single; Gamma: TAHMCanvasColour);
begin
  // Delegate this task to DirectX layer
  if Assigned(FPenColour) then
    DirectXInstance.DrawEllipse(X, Y, XRadius, YRadius, FPenWidth, FPenColour, Gamma);
end;

procedure TAHMCanvas.DrawArc(X, Y, XRadius, YRadius, StartAngle, SweepAngle: Single; Gamma: TAHMCanvasColour);
begin
  // Delegate this task to DirectX layer
  if Assigned(FPenColour) then
  begin
    // Convert angles to DirectX equiv. in radians
    StartAngle := DegToRad(StartAngle + 90);
    SweepAngle := DegToRad(SweepAngle);

    DirectXInstance.DrawArc(X, Y, XRadius, YRadius, StartAngle, SweepAngle, FPenWidth, FPenColour, Gamma);
  end;
end;

procedure TAHMCanvas.FillCircle(X, Y, Radius: Single; Gamma: TAHMCanvasColour);
begin
  // Delegate this task to DirectX layer
  if Assigned(FBrushColour) then
    DirectXInstance.FillCircle(X, Y, Radius, FBrushColour, Gamma);
end;

procedure TAHMCanvas.FillEllipse(X, Y, XRadius, YRadius: Single; Gamma: TAHMCanvasColour);
begin
  // Delegate this task to DirectX layer
  if Assigned(FBrushColour) then
    DirectXInstance.FillEllipse(X, Y, XRadius, YRadius, FBrushColour, Gamma);
end;

procedure TAHMCanvas.FillRect(Rect: TAHMRectF);
begin
  // Delegate to method below with default scale and no shading/gamma
  FillRect(Rect, nil, nil, 1.0, 1.0);
end;

procedure TAHMCanvas.FillRect(Rect: TAHMRectF; Shade: TAHMCanvasShade; Gamma: TAHMCanvasColour;
                              XScale, YScale: Single);
begin
  // Don't render very small objects
  if (XScale < CLIP_SCALE) or (YScale < CLIP_SCALE) then Exit;

  // Delegate this task to DirectX layer
  if Assigned(Shade) then
    DirectXInstance.FillRect(Rect, Shade, Gamma, XScale, YScale)
  else if Assigned(Gamma) then
  begin
    FGammaCalc.Pixel := Gamma.GammaCorrect(FBrushColour);
    DirectXInstance.FillRect(Rect, nil, FGammaCalc, XScale, YScale);
  end
  else
    DirectXInstance.FillRect(Rect, nil, FBrushColour, XScale, YScale);
end;

procedure TAHMCanvas.FillRect(Rect, ClipRect: TAHMRectF; Shade: TAHMCanvasShade; Gamma: TAHMCanvasColour;
                              XScale, YScale: Single);
begin
  // Don't render very small objects
  if (XScale < CLIP_SCALE) or (YScale < CLIP_SCALE) then Exit;

  // Delegate this task to DirectX layer
  if Assigned(Shade) then
    DirectXInstance.FillRect(Rect, ClipRect, Shade, Gamma, XScale, YScale)
  else if Assigned(Gamma) then
  begin
    FGammaCalc.Pixel := Gamma.GammaCorrect(FBrushColour);
    DirectXInstance.FillRect(Rect, ClipRect, nil, FGammaCalc, XScale, YScale);
  end
  else
    DirectXInstance.FillRect(Rect, ClipRect, nil, FBrushColour, XScale, YScale);
end;

procedure TAHMCanvas.FillRoundRect(Rect: TAHMRectF; Gamma: TAHMCanvasColour; CornerRadius, XScale, YScale: Single);
begin
  // Don't render very small objects
  if (XScale < CLIP_SCALE) or (YScale < CLIP_SCALE) then Exit;

  // Delegate this task to DirectX layer
  if Assigned(FBrushColour) then
    DirectXInstance.FillRoundRect(Rect, FBrushColour, Gamma, CornerRadius, XScale, YScale);
end;

procedure TAHMCanvas.ClearRect(Rect: TAHMRectF);
begin
  // Delegate this task to DirectX layer
  DirectXInstance.ClearRect(Rect, FBrushColour);
end;

procedure TAHMCanvas.DrawGraphic(Rect: TAHMRectF; Graphic: TAHMGraphic; Shade: TAHMCanvasShade;
                                 Gamma: TAHMCanvasColour; XScale, YScale: Single; XFlip, YFlip: Boolean);
begin
  // Don't render very small objects
  if (XScale < CLIP_SCALE) or (YScale < CLIP_SCALE) then Exit;

  // Graphic object is responsible for rendering itself via DirectX
  if Assigned(Graphic) then
    Graphic.DrawGraphic(Graphic.ImageRect, Rect, Shade, Gamma, XScale, YScale, XFlip, YFlip);
end;

procedure TAHMCanvas.DrawGraphic(Rect, ClipRect: TAHMRectF; Graphic: TAHMGraphic; Shade: TAHMCanvasShade;
                                 Gamma: TAHMCanvasColour; XScale, YScale: Single; XFlip, YFlip: Boolean);
begin
  // Don't render very small objects
  if (XScale < CLIP_SCALE) or (YScale < CLIP_SCALE) then Exit;

  // Graphic object is responsible for rendering itself via DirectX
  if Assigned(Graphic) then
    Graphic.DrawGraphic(Graphic.ImageRect, Rect, ClipRect, Shade, Gamma, XScale, YScale, XFlip, YFlip);
end;

procedure TAHMCanvas.TextRect(Rect: TAHMRectF; Font: TAHMCanvasFont; Text: String);
begin
  // Delegate to method below with default properties
  TextRect(Rect, Font, Text, taLeft, True, nil, nil, nil, 1.0, 1.0, False, False);
end;

procedure TAHMCanvas.TextRect(Rect: TAHMRectF; Font: TAHMCanvasFont; Text: String; Align: TAHMTextAlign;
                              WordWrap: Boolean; Scroller: TAHMAbstractScroller;
                              Shade: TAHMCanvasShade; Gamma: TAHMCanvasColour;
                              XScale, YScale: Single; XFlip, YFlip: Boolean);
begin
  // Don't render very small objects
  if (XScale < CLIP_SCALE) or (YScale < CLIP_SCALE) then Exit;

  // Delegate this task to DirectX layer
  if Text <> '' then
  begin
    if not Assigned(Font) then Font := TAHMCanvasFont.Default;
    DirectXInstance.TextRect(Rect, Font, Text, Align, WordWrap, Scroller, Shade, Gamma, XScale, YScale, XFlip, YFlip);
  end;
end;

procedure TAHMCanvas.TextRect(Rect, ClipRect: TAHMRectF; Font: TAHMCanvasFont;
                              Text: String; Align: TAHMTextAlign; WordWrap: Boolean;
                              Scroller: TAHMAbstractScroller; Shade: TAHMCanvasShade;
                              Gamma: TAHMCanvasColour; XScale, YScale: Single;
                              XFlip, YFlip: Boolean);
begin
  // Don't render very small objects
  if (XScale < CLIP_SCALE) or (YScale < CLIP_SCALE) then Exit;

  // Delegate this task to DirectX layer
  if Assigned(Font) and (Text <> '') then
  begin
    DirectXInstance.TextRect(Rect, ClipRect, Font, Text, Align, WordWrap, Scroller, Shade, Gamma, XScale, YScale, XFlip, YFlip);
  end;
end;

procedure TAHMCanvas.ReleaseFont(Font: TAHMCanvasFont);
begin
  // Release DirectX font objects
  DirectXInstance.FontManager.ReleaseFont(Font);
end;

procedure TAHMCanvas.Rectangle(Rect: TAHMRectF; Gamma: TAHMCanvasColour);
begin
  // Delegate to method below with default scale
  Rectangle(Rect, Gamma, 1.0, 1.0);
end;

procedure TAHMCanvas.Rectangle(Rect: TAHMRectF; Gamma: TAHMCanvasColour;
                               XScale, YScale: Single);
begin
  // Don't render very small objects
  if (XScale < CLIP_SCALE) or (YScale < CLIP_SCALE) then Exit;

  // Delegate this task to DirectX layer
  if Assigned(FPenColour) then
    DirectXInstance.FrameRect(Rect, FPenColour, Gamma, FPenWidth, XScale, YScale);
end;

procedure TAHMCanvas.RoundRect(Rect: TAHMRectF; Gamma: TAHMCanvasColour; CornerRadius: Single);
begin
  // Delegate to method below with default scale
  RoundRect(Rect, Gamma, CornerRadius, 1.0, 1.0);
end;

procedure TAHMCanvas.RoundRect(Rect: TAHMRectF; Gamma: TAHMCanvasColour; CornerRadius, XScale, YScale: Single);
begin
  // Don't render very small objects
  if (XScale < CLIP_SCALE) or (YScale < CLIP_SCALE) then Exit;

  // Delegate this task to DirectX layer
  if Assigned(FPenColour) then
    DirectXInstance.FrameRoundRect(Rect, FPenColour, Gamma, FPenWidth, CornerRadius, XScale, YScale);
end;

procedure TAHMCanvas.MoveTo(X, Y: Single);
begin
  // Delegate this task to DirectX layer
  DirectXInstance.MoveTo(X, Y);
end;

procedure TAHMCanvas.LineTo(X, Y: Single; Gamma: TAHMCanvasColour);
begin
  // Delegate this task to DirectX layer
  if Assigned(FPenColour) then
    DirectXInstance.LineTo(X, Y, FPenColour, Gamma, FPenWidth);
end;

procedure TAHMCanvas.Line(Rect: TAHMRectF; Gamma: TAHMCanvasColour);
begin
  // Delegate this task to DirectX layer
  if Assigned(FPenColour) then
    with Rect do DirectXInstance.Line(X, Y, X + Width, Y + Height, FPenColour,
                                      Gamma, FPenWidth);
end;

function TAHMCanvas.PrepareGDIText(Font: TAHMCanvasFont): Single;
begin
  Result := 0.0;

  if Assigned(FGraphics) and Assigned(Font) then
  begin
    // Ensure we have a bitmap buffer allocated before preparing canvas
    if Assigned(FBuffer) then FBuffer.AllocateBitmap;

    with Font do
    begin
      // Render font in white so we can apply gamma correction for colour
      FBrush := TGPSolidBrush.Create(aclWhite);

      // Default outline colour to black if not specified
      if Outline then
        if Assigned(OutlineColour) then
          FPen := TGPPen.Create(ARGB(OutlineColour.Pixel), OutlineWidth)
        else
          FPen := TGPPen.Create(aclBlack, OutlineWidth);

      // Determine font style
      FFontStyle := FontStyleRegular;
      if Bold then FFontStyle := FFontStyle or FontStyleBold;
      if Italic then FFontStyle := FFontStyle or FontStyleItalic;
      if Underline then FFontStyle := FFontStyle or FontStyleUnderline;

      // Miscellaneous font properties required for rendering
      if Outline then FFontOutline := OutlineWidth
                 else FFontOutline := 0;
      FFontSize := Size;

      // Create and configure remaining font objects
      FFontFamily := TGPFontFamily.Create(Typeface);
      FFont := TGPFont.Create(FFontFamily, FFontSize, FFontStyle, UnitPixel);
      FFontPath := TGPGraphicsPath.Create;
      FFontFormat := TGPStringFormat.GenericTypographic.Clone;
      FFontFormat.SetFormatFlags(StringFormatFlagsMeasureTrailingSpaces or
                                 StringFormatFlagsNoWrap or
                                 StringFormatFlagsNoFitBlackBox or
                                 StringFormatFlagsNoClip or
                                 StringFormatFlagsNoFontFallback);

      // Set rendering hints for antialiased fonts
      FGraphics.SetTextRenderingHint(TextRenderingHintAntiAlias);
      FGraphics.SetSmoothingMode(SmoothingModeAntiAlias);
    end;

    // Determine font line height for result
    Result := FFont.GetHeight(FGraphics)+ 0.5;
  end;
end;

procedure TAHMCanvas.UnPrepareGDIText;
begin
  FreeAndNil(FPen);
  FreeAndNil(FBrush);
  FreeAndNil(FFontFamily);
  FreeAndNil(FFont);
  FreeAndNil(FFontFormat);
  FreeAndNil(FFontPath);
end;

procedure TAHMCanvas.MeasureGDIText(var Rect: TAHMRectF; Text: WideString);
begin
  if Assigned(FFont) then
  begin
    Rect := MakeRectF(0.0, 0.0, 1000.0, 1000.0);
    FGraphics.MeasureString(Text, Length(Text), FFont, MakePoint(0.0, 0.0), FFontFormat, TGPRectF(Rect));

    // The measurements we get need a bit of fudging to look right
    Rect.Width := Rect.Width + FFontOutline + 0.5;
    Rect.Height := Rect.Height + FFontOutline + 1.5;
  end;
end;

procedure TAHMCanvas.DrawGDIText(X, Y: Single; Text: WideString);
var
  Origin: TGPPointF;
begin
  if Assigned(FFont) then
  begin
    // Offset origin if using outlined font (prevent overlappinh existing chars)
    Origin := MakePoint(X + (FFontOutline * 0.5), Y + (FFontOutline * 0.5));

    if Assigned(FPen) then
    begin
      // Draw font with outline if pen is set
      FFontPath.Reset;
      FFontPath.AddString(Text, Length(Text), FFontFamily, FFontStyle, FFontSize, Origin, FFontFormat);
      FGraphics.FillPath(FBrush, FFontPath);
      FGraphics.DrawPath(FPen, FFontPath);
    end
    else
      FGraphics.DrawString(Text, Length(Text), FFont, Origin, FFontFormat, FBrush);
  end;
end;

//----------------------------------------------------------------------------//

constructor TAHMDrawBuffer.Create;
begin
  inherited Create;

  // Create canvas object and connect to drawbuffer
  FCanvas := TAHMCanvas.Create;
  FCanvas.InternalBuffer := Self;

  // Use alpha blending by default
  FAlphaBlending := True;
  FMonochrome := False;
end;

destructor TAHMDrawBuffer.Destroy;
begin
  FCanvas.Free;
  FBuffer.Free;

  inherited Destroy;
end;

procedure TAHMDrawBuffer.AllocateBitmap;
begin
  // Do we need to create a new bitmap buffer?
  if not Assigned(FBuffer) then
  begin
    // Store appropriate image format to use (16/32 bit)
    FByteFormat := ScreenInstance.TextureFormat;

    // Determine appropriate pixel format to use for our bitmap
    if FMonochrome then FBitmapFormat := PixelFormat32bppARGB else
      case FByteFormat of
        tf32Bit: if FAlphaBlending then FBitmapFormat := PixelFormat32bppARGB
                                   else FBitmapFormat := PixelFormat32bppRGB;
        else if FAlphaBlending then FBitmapFormat := PixelFormat16bppARGB1555
                               else FBitmapFormat := PixelFormat16bppRGB565;
      end;

    // Create appropriate format bitmap and reconnect to canvas
    // Note that we always create a 32bit ARGB bitmap for rendering
    // then lock it later in a format closer to our intended surface
    FBuffer := TGPBitmap.Create(FWidth, FHeight, PixelFormat32bppARGB);
    FCanvas.InternalBuffer := Self;
  end;
end;

procedure TAHMDrawBuffer.SetWidth(Width: Integer);
begin
  // If dimensions change we will need to recreate our bitmap buffer
  if FWidth <> Width then
  begin
    FWidth := Width;
    FreeAndNil(FBuffer);
  end;
end;

procedure TAHMDrawBuffer.SetHeight(Height: Integer);
begin
  // If dimensions change we will need to recreate our bitmap buffer
  if FHeight <> Height then
  begin
    FHeight := Height;
    FreeAndNil(FBuffer);
  end;
end;

function TAHMDrawBuffer.GetBufferRect: TAHMRect;
begin
  Result := MakeRect(0, 0, FWidth, FHeight);
end;

function TAHMDrawBuffer.ProcessBitmap(Process: TAHMBitmapProcess): Boolean;
begin
  AllocateBitmap;

  // Apply requested image processing algorithm to buffer
  case Process of
    bpGlow: Result := TAHMImageProcessor.GaussianGlow(FBuffer, 7);
    else Result := False;
  end;
end;

function TAHMDrawBuffer.LockBitmap(Rect: TAHMRect; var Lock: TAHMBitmapData): Boolean;
var
  Status: TStatus;
  LockMode: TAHMDBLockMode;
  LockFlags: Integer;
begin
  Result := False;

  AllocateBitmap;
  if FLocked then
  begin
    LogError('Attempted to relock previously locked GDI bitmap for direct access');
    Exit;
  end;

  // Determine locking requirements and clear lock record
  LockMode := Lock.LockMode;
  FillChar(Lock, SizeOf(TAHMBitmapData), 0);
  Lock.LockMode := LockMode;
  if LockMode = lmRead then LockFlags := ImageLockModeRead
                       else LockFlags := ImageLockModeWrite;

  // Clip requested lock to size of drawbuffer
  ClipRect(Rect, GetBufferRect);

  // Attempt to aquire the lock for our required format
  Status := FBuffer.LockBits(TGPRect(Rect), LockFlags, FBitmapFormat, FLockData);
  if Status <> Ok then
    LogWarn('Failed to lock GDI bitmap for direct access: ' + IntToStr(Ord(Status)))
  else
  begin
    // Successfully aquired lock, pass details back to caller
    Result := True;
    FLocked := True;
    Lock.Width := FLockData.Width;
    Lock.Height := FLockData.Height;
    Lock.RowDelta := FLockData.Stride;
    Lock.PixelData := FLockData.Scan0;
    if FMonochrome or (FByteFormat = tf32Bit) then Lock.BytesPerPixel := 4
                                              else Lock.BytesPerPixel := 2;
  end;
end;

procedure TAHMDrawBuffer.UnlockBitmap;
begin
  // Release previous lock on bitmap data
  if FLocked and Assigned(FBuffer) then
    FBuffer.UnlockBits(FLockData);
  FLocked := False;
end;

procedure TAHMDrawBuffer.SaveBitmap(Filename: String);
var
  Clsid: TGUID;
  Mime: String;
begin
  // Save bitmap to file
  if Assigned(FBuffer) then
  begin
    // Build a mime type based on file extension
    Mime := LowerCase(ExtractFileExt(Filename));
    Mime := 'image/' + StringReplace(Mime, '.', '', [rfReplaceAll]);

    // Encoder supports bmp,jpeg,gif,tiff,png mime types
    if GetEncoderClsid(Mime, Clsid) <> -1 then
      FBuffer.Save(Filename, Clsid);
  end;
end;


initialization
  DefaultFontInstance := nil;

finalization
  DefaultFontInstance.Free;

end.
